Tips&Tricks

I trucchi del mestiere

Numeri binari con Visual Basic

Una serie di funzioni che permettono di "lavorare" con i numeri binari; nella fattispecie sono implementate le seguenti procedure e/o funzioni:
- DecTOBin e BinTODec permettono di convertire valori di byte nel loro corrispettivo binario e vice versa.
- GetLowHightValueBits restituisce I valori dei bits alti e bassi all'interno di un byte.
- SplitLongValues, SplitIntegerValues, MergeLongValues e MergeIntegerValues scompogno e ricompongono numeri Integer e Long nei (oppure a partire da i) loro sotto byte.
- ShiftByte permette di compiere operazioni tipo Mid$ sui valori dei Bits di un singolo byte restituendo poi il valore risultante.
Tip fornito dal Sig. S.Tubini

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Enum ShiftType
    RightShift = 1
    LeftShift = 2
End Enum

Public Sub GetLowHightValueBits(bValue As Byte, lValue As Byte, hValue As Byte)
Dim BitArr(7) As Byte, LBArr(7) As Byte, HBArr(7) As Byte

    DecTOBin bValue, BitArr()

    LBArr(0) = BitArr(7)
    LBArr(1) = BitArr(6)
    LBArr(2) = BitArr(5)
    LBArr(3) = BitArr(4)

    HBArr(0) = BitArr(3)
    HBArr(1) = BitArr(2)
    HBArr(2) = BitArr(1)
    HBArr(3) = BitArr(0)
    
    lValue = BinTODec(LBArr())
    hValue = BinTODec(HBArr())

End Sub

Public Sub DecTOBin(bValue As Byte, BitArr() As Byte)
Dim I As Long

    For I = 1 To bValue Step 1
      If BitArr(7) = 1 Then
        
        BitArr(7) = 0
        If BitArr(6) = 1 Then
        
            BitArr(6) = 0
            If BitArr(5) = 1 Then
            
                BitArr(5) = 0
                If BitArr(4) = 1 Then
                
                    BitArr(4) = 0
                    If BitArr(3) = 1 Then
                    
                        BitArr(3) = 0
                        If BitArr(2) = 1 Then
                        
                            BitArr(2) = 0
                            If BitArr(1) = 1 Then
                            
                                BitArr(1) = 0
                                BitArr(0) = 1
                            
                            Else
                                BitArr(1) = 1
                            End If
                        
                        Else
                            BitArr(2) = 1
                        End If
                    
                    Else
                        BitArr(3) = 1
                    End If
                
                Else
                    BitArr(4) = 1
                End If
                
            Else
                BitArr(5) = 1
            End If
        
        Else
            BitArr(6) = 1
        End If
      
      Else
        BitArr(7) = 1
      End If
    
    Next

End Sub

Public Function BinTODec(BitIn() As Byte) As Byte
Dim I As Long, BitArr(7) As Byte

    For I = 1 To 255 Step 1
      If BitArr(7) = 1 Then
        
        BitArr(7) = 0
        If BitArr(6) = 1 Then
        
            BitArr(6) = 0
            If BitArr(5) = 1 Then
            
                BitArr(5) = 0
                If BitArr(4) = 1 Then
                
                    BitArr(4) = 0
                    If BitArr(3) = 1 Then
                    
                        BitArr(3) = 0
                        If BitArr(2) = 1 Then
                        
                            BitArr(2) = 0
                            If BitArr(1) = 1 Then
                            
                                BitArr(1) = 0
                                BitArr(0) = 1
                            
                            Else
                                BitArr(1) = 1
                            End If
                        
                        Else
                            BitArr(2) = 1
                        End If
                    
                    Else
                        BitArr(3) = 1
                    End If
                
                Else
                    BitArr(4) = 1
                End If
                
            Else
                BitArr(5) = 1
            End If
        
        Else
            BitArr(6) = 1
        End If
      
      Else
        BitArr(7) = 1
      End If
    
      If BitIn(0) = BitArr(0) And BitIn(1) = BitArr(1) And BitIn(2) = BitArr(2) And BitIn(3) = 
BitArr(3) And BitIn(4) = BitArr(4) And BitIn(5) = BitArr(5) And BitIn(6) = 
BitArr(6) And BitIn(7) = BitArr(7) Then
            BinTODec = I
            Exit For
      End If
     Next

End Function

Public Sub SplitLongValues(lValue As Long, ByteArr() As Byte)
    CopyMemory ByteArr(0), lValue, 4
End Sub

Public Sub SplitIntegerValues(iValue As Integer, ByteArr() As Byte)
    CopyMemory ByteArr(0), lValue, 2
End Sub

Public Function MergeLongValues(ByteArr() As Byte) As Long
    CopyMemory MergeLongValues, ByteArr(), 4
End Function

Public Function MergeIntegerValues(ByteArr() As Byte) As Integer
    CopyMemory MergeIntegerValues, ByteArr(), 2
End Function

Public Function ShiftByte(bValue As Byte, nBitStart As Byte, nSize As Byte, ShiftMode As 
ShiftType) As Byte

On Local Error Resume Next
Dim bArr(7) As Byte
Dim NewbArr(7) As Byte

Dim I As Long,, nStep As Long, nSkip As Long
If (nBitStart + nSize * nStep) < 8 Or (nBitStart + nSize * nStep) > -1 And nBitStart < 8 Then

    If ShiftMode = LeftShift Then
        nStep = -1
    ElseIf ShiftMode = RightShift Then
        nStep = 1
    End If

    DecTOBin bValue, bArr()
    nSkip = 7
    For  I = (7 - nBitStart) To (7 - (nBitStart + nSize - 1)) Step nStep
        NewbArr(nSkip) = bArr(I)
        nSkip = nSkip - 1
    Next
End If

If Err <> 0 Then Err = 0: Exit Function
ShiftByte = BinTODec(NewbArr())
End Function

Grafici a torta? Sempliceà

Un piccolo ma funzionale tip che consente di creare grafici a torta senza utilizzare nessun ActiveX di supporto.
Tip fornito dal Sig. Luciano Busetti
Il codice del progetto Φ presente nella sezione codice del Cd-Rom allegato o sul Web: cdrom.ioprogrammo.net

Alla ricerca del file perduto

Un tip che consente di cercare un qualunque file contenuto in qualunque hard-disk installato nel personal computer. L'intera operazione di ricerca Φ affidata a delle API di sistema in grado di interagire direttamente con il FileSystem di Windows. Per la ricerca Φ anche possibile inserire il carattere jolly "*"Es.: "*.txt"; in output fornisce:
1. Il numero di File trovati
2. Il numero di Cartelle nelle quali ha cercato
3. La grandezza complessiva in Byte dei file trovati
4. Come parametro di ritorno una stringa contenente i percorsi dei file che sono stati trovati separati dal carattere "|"
Tip fornito dal Sig. Alessandro Castaldo

'Creare un Form con:
'un TextBox nominato Text1 per la Cartella di ricerca
'un TextBox nominato Text2 per il nome del file da cercare
'un CommandButton nominato Command1 per avviare la ricerca


Option Explicit

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA"
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias
"GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long)
As Long


Const MAX_PATH = 260
Const MAXDWORD = &HFFFF

Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20

Const FILE_ATTRIBUTE_DIRECTORY = &H10

Const FILE_ATTRIBUTE_HIDDEN = &H2

Const FILE_ATTRIBUTE_NORMAL = &H80

Const FILE_ATTRIBUTE_READONLY = &H1

Const FILE_ATTRIBUTE_SYSTEM = &H4

Const FILE_ATTRIBUTE_TEMPORARY = &H100



Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type


Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type



Private Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function


Private Function FindFilesAPI(ByVal Path As String, ByVal SearchStr As
String, ByRef FileCount As Long, ByRef DirCount As Long, ByRef FoundFiles As
String)


    Dim FileName As String
    Dim DirName As String
    Dim dirNames() As String
    Dim nDir As Long
    Dim i As Long
    Dim hSearch As Long
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Long


    DoEvents


    If Right(Path, 1) <> "\" Then Path = Path & "\"
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
    hSearch = FindFirstFile(Path & "*", WFD)
    If hSearch <> INVALID_HANDLE_VALUE Then
        Do While Cont
        DirName = StripNulls(WFD.cFileName)
        If (DirName <> ".") And (DirName <> "..") Then
            If GetFileAttributes(Path & DirName) And
FILE_ATTRIBUTE_DIRECTORY Then
                dirNames(nDir) = DirName
                DirCount = DirCount + 1
                nDir = nDir + 1
                ReDim Preserve dirNames(nDir)
            End If
        End If
        Cont = FindNextFile(hSearch, WFD)
        Loop
        Cont = FindClose(hSearch)
    End If
    hSearch = FindFirstFile(Path & SearchStr, WFD)
    Cont = True
    If hSearch <> INVALID_HANDLE_VALUE Then
        While Cont
            FileName = StripNulls(WFD.cFileName)
            If (FileName <> ".") And (FileName <> "..") Then
                FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD)
+ WFD.nFileSizeLow
                FileCount = FileCount + 1
                If FoundFiles <> "" Then FoundFiles = FoundFiles & "|"
                FoundFiles = FoundFiles & Path & FileName
            End If
            Cont = FindNextFile(hSearch, WFD)
        Wend
        Cont = FindClose(hSearch)
    End If
    If nDir > 0 Then
        For i = 0 To nDir - 1
            FindFilesAPI = FindFilesAPI + FindFilesAPI(Path & dirNames(i) &
"\", SearchStr, FileCount, DirCount, FoundFiles)
        Next i
    End If


End Function


Public Function FindFile(ByVal SearchPath As String, ByVal SearchStr As
String, ByRef FileCount As Long, ByRef DirCount As Long, ByRef FileSize As
Long) As String
    FileSize = FindFilesAPI(SearchPath, SearchStr, FileCount, DirCount,
FindFile)
End Function

Sub Command1_Click()
    Dim FileSize As Long
    Dim FileCount As Long
    Dim DirCount As Long
    Dim OutMessage As String
    Dim FoundFiles As String


    Screen.MousePointer = vbHourglass
    Command1.Enabled = False
    FoundFiles = FindFile(Text1.Text, Text2.Text, FileCount, DirCount,
FileSize)
    Command1.Enabled = True
    Screen.MousePointer = vbDefault
    FoundFiles = Replace(FoundFiles, "|", vbCrLf)
    OutMessage = OutMessage & FoundFiles & vbCrLf
    OutMessage = OutMessage & vbCrLf
    OutMessage = OutMessage & FileCount & " file trovati in " & DirCount + 1
& " cartelle"
    OutMessage = OutMessage & vbCrLf
    OutMessage = OutMessage & "La dimensione dei file trovati in " &	
Text1.Text & " Φ " & Format(FileSize, "#,###,###,##0") & " Byte"
    MsgBox OutMessage, , "Risultato ricerca"
End Sub